perm filename MATCH[PAT,LMM]2 blob
sn#065070 filedate 1973-09-28 generic text, type T, neo UTF8
(FILECREATED "28-SEP-73 20:16:04" MATCH)
(LISPXPRINT (QUOTE MATCHVARS)
T)
[RPAQQ MATCHVARS
((* TOP LEVEL)
(FNS MAKEMATCH 'MATCHWM 'MATCHTOP 'MATCHEXP 'MATCHELT
'MATCHSUBPAT)
(* Funargs for 'MATCHWM)
(FNS MAKE'SETQ MAKEPOSTPONEDSETQ MAKE'REPLACE
MAKEPOSTPONEDREPLACE MAKE'APPLY* MAKE'RETURN MAKE*GLITCH)
(* PREDICATES ON PATTERNS)
(FNS SKIP$I SKIP$ANY PATLEN $? ELT? ARB? NULLPAT? CANMATCHNIL
CANMATCHNILLIST REPLACEIN REPLACED)
(* LISP FUNCTION MANIPULATION)
(FNS EASYTORECOMPUTE FULLEXPANSION GENSYML MAKESUBST0
MAKESUBSTLIST MAKESUBSTLIST1 FORMEXPAND POSTPONEDREPLACE
POSTPONEDSETQ POSTPONE SUBSTVAR BOUNDVAR BINDVAR
SELFQUOTEABLE FINDIN0 FINDIN1 DOWATCH UNCROP)
(* LISP FUNCTION CONSTRUCTION)
(FNS 'NLEFT 'NOT 'NULL 'NOT1 'NOTLESSPLENGTH 'NTH 'OR 'PLUS
'REPLACE 'SETQ 'AND 'AND2 'CAR 'CDR 'EQ 'EQLENGTH 'EQUAL
'LAST 'RETURN 'F/L 'APPLY* 'HEADPLOOP 'LDIFF 'PROG 'FOR
'PROGN 'LISTP)
(* PATTERN PARSER)
(FNS PATPARSE PATPARSE1 PATPARSEAT PATPARSEXPR BI12
MAKEDEFAULT MAKE!PAT MAKESUBPAT)
(* FUNCTIONS, CALLS TO WHICH ARE GENERATED)
(FNS EQLENGTH RPLNODE2 /RPLNODE2)
(* MISC)
(FNS PATERR PATWARN LOOKLIST LOOK CLISPLOOKUP VARCHECK TRUE)
(VARS VARDEFAULT MAXCDDDDRS POSTPONEFLG PATCHECKLENGTH
POSTPONEFLG PATCAREVALUE CRLIST PATCHARS
PATNONNILFUNCTIONS PATVARSMIGHTBENIL)
(PROP MACRO EVERY)
[ADDVARS (PRETTYMACROS (* X (E (TERPRI)
(PRINT (QUOTE (* . X)))
(TERPRI]
[P (SETQ PATCHARRAY (MAKEBITTABLE (MAPCAR PATCHARS
(QUOTE CAR]
(BLOCKS (MATCHBLOCK MAKEMATCH 'MATCHWM 'MATCHTOP 'MATCHEXP
'MATCHELT 'MATCHSUBPAT MAKE'SETQ
MAKEPOSTPONEDSETQ MAKE'REPLACE
MAKEPOSTPONEDREPLACE MAKE'APPLY*
MAKE'RETURN MAKE*GLITCH SKIP$I SKIP$ANY
PATLEN $? ELT? ARB? NULLPAT? CANMATCHNIL
CANMATCHNILLIST REPLACEIN REPLACED
EASYTORECOMPUTE FULLEXPANSION GENSYML
MAKESUBST0 MAKESUBSTLIST MAKESUBSTLIST1
FORMEXPAND POSTPONEDREPLACE POSTPONEDSETQ
POSTPONE SUBSTVAR BOUNDVAR BINDVAR
SELFQUOTEABLE FINDIN0 FINDIN1 DOWATCH
UNCROP 'NLEFT 'NOT 'NULL 'NOT1
'NOTLESSPLENGTH 'NTH 'OR 'PLUS 'REPLACE
'SETQ 'AND 'AND2 'CAR 'CDR 'EQ 'EQLENGTH
'EQUAL 'LAST 'RETURN 'APPLY* 'HEADPLOOP
'LDIFF 'PROG 'FOR 'F/L 'PROGN 'LISTP
PATPARSE PATPARSE1 PATPARSEAT PATPARSEXPR
BI12 MAKEDEFAULT MAKE!PAT MAKESUBPAT
PATERR PATWARN CLISPLOOKUP VARCHECK TRUE
(ENTRIES MAKEMATCH)
(GLOBALVARS PATCHARRAY PATCHARS
POSTPONEFLG VARDEFAULT CRLIST
PATCHECKLENGTH MAXCDDDDRS
PATNONNILFUNCTIONS
PATVARSMIGHTBENIL)
(LOCALFREEVARS WATCHPOSTPONELST SUBLIST
TOPPAT INASOME
CHECKINGLENGTH WMLST
LASTEFFECTCANBENIL
POSTPONEDEFFECTS
MUSTRETURN BINDINGS
GENSYMVARLIST SKIPEDLEN
ZLENFLG SUBPRS
STARREPLACED)
(SPECVARS STARREPLACED)
(BLKAPPLYFNS TRUE MAKE'RETURN MAKE*GLITCH
MAKE'SETQ MAKEPOSTPONEDSETQ
MAKE'REPLACE
MAKEPOSTPONEDREPLACE
MAKE'APPLY* 'MATCHWM
'MATCHSUBPAT))
(NIL EQLENGTH (LINKFNS . T]
(* TOP LEVEL)
(DEFINEQ
(MAKEMATCH
[LAMBDA (VAR TOPPAT STARREPLACED)
('MATCHTOP VAR (PATPARSE TOPPAT])
('MATCHWM
[LAMBDA (VAR PAT FN)
(* Creates an expression which will return non-NIL
if and only if the value of the VAR expression will
match the parsed pattern PAT, and the expression
generated by applying (CAR FN) to
(the expression giving What-Matched the first
pattern element of PAT) and
(CDR FN) -
is non-nil as well. FN can hide side effects as
well)
(PROG (TEM1 TEM2 TAIL (SKIPEDLEN 0)
ZLENFLG IN@FLG)
RETRY
(COND
[(NULL PAT)
(RETURN (OR (NOT CHECKINGLENGTH)
('NULL VAR]
[(NLISTP (CAR PAT))
(COND
([NOT (FMEMB (CAR PAT)
(QUOTE ($ --]
(GO ELT))
(T (GO TAIL]
((FMEMB (CAAR PAT)
(QUOTE (= == ' SUBPAT)))
(GO ELT))
((EQ (CAAR PAT)
(QUOTE !))
(GO BANG))
((EQ (CAAR PAT)
(QUOTE $PACKED$))
(GO PACKED)))
[SETQ FN (SELECTQ (CAAR PAT)
(←(CONS (FUNCTION MAKE'SETQ)
(CONS (CDAR PAT)
FN)))
(<-(CONS (FUNCTION MAKEPOSTPONEDSETQ)
(CONS (CDAR PAT)
FN)))
(→ (CONS (FUNCTION MAKE'REPLACE)
(CONS (CDAR PAT)
FN)))
(-> (CONS (FUNCTION MAKEPOSTPONEDREPLACE)
(CONS (CDAR PAT)
FN)))
(@ (CONS (FUNCTION MAKE'APPLY*)
(CONS (CDAR PAT)
FN)))
(* (CONS (FUNCTION MAKE'RETURN)
FN))
(*GLITCH (CONS (FUNCTION MAKE*GLITCH)
(CONS (CDAR PAT)
FN)))
(HELP "INVALID PATTERN" (CAR PAT]
(FRPLACA PAT (SELECTQ (CAAR PAT)
(* (CDAR PAT))
(CDDAR PAT)))
(GO RETRY)
BANG[RETURN
(COND
[(NULL (CDR PAT))
('AND (BLKAPPLY* (CAR FN)
VAR
(CDR FN))
(COND
[(EQ (CADAR PAT)
(QUOTE SUBPAT))
(* This isn't really a subpat and so don't rebind
CHECKINGLENGTH etc as in 'MATCHSUBPAT)
('MATCHWM VAR (CDDAR PAT)
(QUOTE (TRUE]
(T ('MATCHELT VAR (CDAR PAT]
((NLISTP (CAR PAT))
(PATERR "INVALID !"))
(T
(SELECTQ
(CADAR PAT)
[= (* !=)
('HEADPLOOP VAR (CDDAR PAT)
(SETQ TEM1 (BOUNDVAR))
(CANMATCHNILLIST (CDR PAT))
('AND (BLKAPPLY* (CAR FN)
('LDIFF VAR TEM1)
(CDR FN))
('MATCHWM TEM1 (CDR PAT)
(QUOTE (TRUE]
(==(PATERR "!== in middle of pattern"))
('(AND [OR (NLISTP (CDDAR PAT))
(CDR (LAST (CDDAR PAT]
(PATERR "!'atom in middle of pattern"))
('MATCHWM
VAR
(CONS
[CONS (QUOTE !)
(CONS (QUOTE SUBPAT)
(MAPCAR (CDDAR PAT)
(FUNCTION (LAMBDA (X)
(CONS (QUOTE ')
X]
(CDR PAT))
FN))
(SUBPAT
(* USE THE *GLITCH KLUDGE TO GET THE WHATMATCHED OF
THE REST OF THE THING)
(COND
[(EQ (CAR FN)
(QUOTE TRUE))
('MATCHWM VAR (APPEND (CDDAR PAT)
(CDR PAT))
(QUOTE (TRUE]
(T
(SETQ WMLST (CONS NIL WMLST))
[SETQ TEM1
('AND
('MATCHWM
VAR
[APPEND
(CDDAR PAT)
(LIST
(CONS
(QUOTE *GLITCH)
(CONS WMLST
(CONS (QUOTE !)
(CONS (QUOTE SUBPAT)
(CDR PAT]
(QUOTE (TRUE)))
(BLKAPPLY* (CAR FN)
('LDIFF VAR (CAR WMLST))
(CDR FN]
(SETQ WMLST (CDR WMLST))
TEM1)))
(HELP "INVALID PATTERN HERE:" (CADAR PAT]
PACKED
[RETURN (COND
[(NULL (CDR PAT))
('AND (OR (NOT CHECKINGLENGTH)
('EQLENGTH VAR (CDAR PAT)))
(BLKAPPLY* (CAR FN)
VAR
(CDR FN]
[(AND (EQ (CAR FN)
(QUOTE TRUE))
(COND
[[NULLPAT? (SETQ TAIL (SKIP$I (CDR PAT]
(OR (NOT CHECKINGLENGTH)
('NOTLESSPLENGTH VAR
('PLUS (CDAR PAT)
SKIPEDLEN]
((NULL TAIL)
('EQLENGTH VAR ('PLUS (CDAR PAT)
SKIPEDLEN]
(T [SETQ TEM1 (SUBSTVAR ('NTH VAR (CDAR PAT]
('AND (OR (NOT (CANMATCHNILLIST (CDR PAT)))
TEM1)
(BLKAPPLY* (CAR FN)
('LDIFF VAR ('CDR TEM1))
(CDR FN))
('MATCHWM ('CDR TEM1)
(CDR PAT)
(QUOTE (TRUE]
ELT [RETURN
('AND
[OR (NOT CHECKINGLENGTH)
(COND
[(CANMATCHNIL (CAR PAT))
(COND
((NULL (CDR PAT))
('EQLENGTH VAR 1))
((NULLPAT? (CDR PAT))
VAR)
(T (OR (NOT (CANMATCHNILLIST (CDR PAT)))
VAR]
(T (COND
((NULL (CDR PAT))
('NULL ('CDR VAR)))
(T T]
('MATCHELT ('CAR VAR)
(CAR PAT))
(BLKAPPLY* (CAR FN)
('CAR VAR)
(CDR FN))
(OR (NULL (CDR PAT))
('MATCHWM ('CDR VAR)
(CDR PAT)
(QUOTE (TRUE]
TAIL[COND
[(NULL (CDR PAT)) (* Pattern ends in --)
(RETURN (BLKAPPLY* (CAR FN)
VAR
(CDR FN]
[(ARB? (CADR PAT))
(COND
((MEMB (QUOTE MAKE'APPLY*)
FN)
(* Got ($@FOO $ ...) this is
($ ! ($ ...) @ (lambda (z)
(FOO (LDIFF var z)))))
(SETQ IN@FLG T)
(GO MAKESOME))
(INASOME (GO INASOME))
[(OR (SKIP$ANY (CDDR PAT))
(NOT (ZEROP SKIPEDLEN)))
(* ($ ARB -- }FIXED) I.e. two arb's in a row,
followed by something)
(PATWARN
"Two arbitrary segments in a row - ignoring first")
('AND (BLKAPPLY* (CAR FN)
NIL
(CDR FN))
('MATCHWM VAR (CDR PAT)
(QUOTE (TRUE]
(T
(* Have two $'s in a row -- kludge to mean last, if
there isn't anything after the second one)
(GO LASTKLUDGE]
(INASOME (GO INASOME))
([AND (EQ (CAR FN)
(QUOTE TRUE))
(PROGN (SETQ TAIL (SKIP$I (CDR PAT)))
(NOT (ZEROP SKIPEDLEN]
(* Special check here, since might have
(... -- $4) or not need any 'NLEFT's)
(GO STARTWITH$N))
([NULL (SETQ TAIL (SKIP$ANY (CDR PAT]
(GO ENDINFIXED))
([AND (EQ (CAR FN)
(QUOTE TRUE))
(EQ TAIL (CDDR PAT))
(EQ SKIPEDLEN 1)
(NULLPAT? TAIL)
(EQ (CAADR PAT)
(QUOTE SUBPAT))
(EVERY (CDDR (CADR PAT))
(FUNCTION ARB?))
[COND
[(NLISTP (CADR (CADR PAT)))
(NOT (FMEMB (CADR (CADR PAT))
(QUOTE (& $ --]
(T (FMEMB (CAR (CADR (CADR PAT)))
(QUOTE (= == ']
(FMEMB [CAR (SETQ TEM1 ('MATCHELT
(QUOTE DUMMY)
(CADR (CADR PAT]
(QUOTE (EQ EQUAL] (* PAT: (-- (SUBPAT
EQTYPE? ARB?) --))
(RETURN ('MATCHEXP
(LIST (SELECTQ (CAR TEM1)
(EQ (LOOK (QUOTE ASSOC)
VAR))
(QUOTE SASSOC))
(CADDR TEM1)
VAR)
(CONS (QUOTE &)
(CDDR (CADR PAT)))
NIL
(QUOTE 'MATCHSUBPAT]
MAKESOME
[RETURN (PROG ({OLD⎇ {FINALLY⎇EXPR {UNTIL⎇EXPR {ON⎇VAR
(TEMVAR (GENSYML))
(INASOME (QUOTE INASOME)))
(SETQ WATCHPOSTPONELST (CONS TEMVAR
WATCHPOSTPONELST))
(* WATCHPOSTPONELST is reset so that postponed uses
of it can be detected; needed to set {OLD⎇)
(COND
((AND (REPLACED (CDR PAT))
(EQ (CAR (SETQ TEM1 (FULLEXPANSION
VAR)))
(QUOTE CDR)))
(SETQ {ON⎇VAR (CADR TEM1))
(SETQ TEM2 ('CDR TEMVAR)))
(T (SETQ {ON⎇VAR VAR)
(SETQ TEM2 TEMVAR)))
[SETQ {UNTIL⎇EXPR ('MATCHWM TEM2 (CDR PAT)
(QUOTE (TRUE]
[COND
(IN@FLG [SETQ {UNTIL⎇EXPR
('AND {UNTIL⎇EXPR
(BLKAPPLY* (CAR FN)
('LDIFF VAR TEM2)
(CDR FN]
(SETQ {FINALLY⎇EXPR
(OR (EQ INASOME (QUOTE INASOME))
INASOME)))
(T (SETQ {FINALLY⎇EXPR
('AND (BLKAPPLY* (CAR FN)
('LDIFF VAR TEM2)
(CDR FN))
(OR (EQ INASOME (QUOTE INASOME))
INASOME]
(SETQ {OLD⎇ (EQ (CAR WATCHPOSTPONELST)
(QUOTE FOUND)))
(SETQ WATCHPOSTPONELST (CDR WATCHPOSTPONELST))
('FOR {OLD⎇ TEMVAR {ON⎇VAR {UNTIL⎇EXPR
{FINALLY⎇EXPR (CANMATCHNILLIST
(CDR PAT]
ENDINFIXED
[RETURN
(PROG (CHECKINGLENGTH)
(* If pat ends in (... -- & & &) then just match
(NLEFT var 3) against & & &;
CECHINGLENGTH will keep a (NULL
(CDDDR x)) check away)
(COND
[(AND (REPLACED (CDR PAT))
(EQ (CAR (SETQ TEM2 (FULLEXPANSION VAR)))
(QUOTE CDR)))
(SETQ TEM1 (SUBSTVAR ('NLEFT (CADR TEM2)
('PLUS SKIPEDLEN 1)
NIL ZLENFLG)))
('AND
[OR (NOT (EVERY (CDR PAT)
(FUNCTION CANMATCHNIL)))
(COND
((ZEROP SKIPEDLEN)
TEM1)
(T ('CDR TEM1]
('MATCHWM ('CDR TEM1)
(CDR PAT)
(QUOTE (TRUE)))
(BLKAPPLY* (CAR FN)
('LDIFF VAR ('CDR TEM1))
(CDR FN]
[(ZEROP SKIPEDLEN)
(SETQ TEM1 (SUBSTVAR (LIST (QUOTE LAST)
VAR)))
('AND (COND
((CANMATCHNILLIST (CDR PAT))
TEM1))
('MATCHWM ('CDR TEM1)
(CDR PAT)
(QUOTE (TRUE)))
(BLKAPPLY* (CAR FN)
('LDIFF VAR ('CDR TEM1))
(CDR FN]
(T
(SETQ TEM1 (SUBSTVAR ('NLEFT VAR SKIPEDLEN NIL
ZLENFLG)))
('AND
(OR (NOT (EVERY (CDR PAT)
(FUNCTION CANMATCHNIL)))
TEM1)
('MATCHWM TEM1 (CDR PAT)
(QUOTE (TRUE)))
(BLKAPPLY* (CAR FN)
('LDIFF VAR TEM1)
(CDR FN]
STARTWITH$N (* Starts with -- $N's
--)
[RETURN (COND
((OR (NULL TAIL)
(NULLPAT? TAIL))
(OR (NOT CHECKINGLENGTH)
('NOTLESSPLENGTH VAR SKIPEDLEN)))
[(NUMBERP SKIPEDLEN)
('MATCHWM ('NTH VAR (ADD1 SKIPEDLEN))
(CONS (CAR PAT)
TAIL)
(QUOTE (TRUE]
(T [SETQ TEM1 (SUBSTVAR ('NTH VAR ('PLUS SKIPEDLEN
1]
('MATCHWM ('CDR TEM1)
(CONS (CAR PAT)
TAIL)
(QUOTE (TRUE]
LASTKLUDGE
[RETURN (COND
[(REPLACED (CDR PAT))
(SETQ TEM1 (SUBSTVAR ('NLEFT VAR 2)))
('AND (OR (NOT (CANMATCHNILLIST (CDR PAT)))
TEM1)
('MATCHWM ('CDR TEM1)
(CDR PAT)
(QUOTE (TRUE)))
(BLKAPPLY* (CAR FN)
('LDIFF VAR ('CDR TEM1))
(CDR FN]
(T (* Must mean the second
is LAST)
(SETQ TEM1 (SUBSTVAR ('LAST VAR)))
('AND ('MATCHWM TEM1 (CDR PAT)
(QUOTE (TRUE)))
(BLKAPPLY* (CAR FN)
('LDIFF VAR TEM1)
(CDR FN]
INASOME
(* Reset INASOME to the match of this pattern, and
then return T; thus the INASOME will get the correct
thing to match, and yet *GLITCHES will work properly
as well (maybe))
(COND
((NEQ INASOME (QUOTE INASOME))
(HELP "error in pattern matcher - SOME INASOME")))
(SETQ INASOME (PROG (INASOME)
('MATCHWM VAR PAT FN)))
(RETURN T])
('MATCHTOP
[LAMBDA (EXPRESSION PAT) (* Generate expresion
which will match PAT
against EXPRESSION)
(PROG ((GENSYMVARLIST (QUOTE (GENSYMVARS: $$1 $$2 $$3 $$4 $$5 $$6
$$7 $$8 $$9 $$10 $$11
$$12 $$13 $$14 $$15 $$16
$$17)))
(CHECKINGLENGTH PATCHECKLENGTH)
POSTPONEDEFFECTS LASTEFFECTCANBENIL BINDINGS MUSTRETURN
WMLST ZLENFLG SUBLIST INASOME WATCHPOSTPONELST)
(* POSTPONEDEFFECTS is the side effects postponed -
BINDINGS will be list of prog bindings that need to
be done -
MUSTRETURN will be the * expression, if any)
(SETQ EXPRESSION ('MATCHEXP EXPRESSION PAT (QUOTE (TRUE))
(QUOTE 'MATCHWM)))
[COND
(MUSTRETURN (SETQ POSTPONEDEFFECTS (NCONC1 POSTPONEDEFFECTS
MUSTRETURN)))
((AND LASTEFFECTCANBENIL PATCAREVALUE)
(SETQ POSTPONEDEFFECTS (NCONC1 POSTPONEDEFFECTS T]
[COND
(POSTPONEDEFFECTS (SETQ EXPRESSION ('AND EXPRESSION
('PROGN
POSTPONEDEFFECTS]
(AND SUBLIST (SETQ EXPRESSION (MAKESUBSTLIST (DREVERSE
SUBLIST)
EXPRESSION)))
(RETURN (COND
(BINDINGS ('PROG BINDINGS (LIST EXPRESSION)))
(T EXPRESSION])
('MATCHEXP
[LAMBDA (VAR PAT 3RDARG FN)
(COND
((EASYTORECOMPUTE VAR)
(BLKAPPLY* FN VAR PAT 3RDARG))
(T (PROG (TEM2)
(COND
([AND (REPLACED PAT)
(FMEMB (CAR (SETQ TEM2 (FULLEXPANSION VAR)))
(QUOTE (CAR CDR]
(BLKAPPLY* FN (LIST (CAR TEM2)
(SUBSTVAR (CADR TEM2)))
3RDARG))
(T (BLKAPPLY* FN (SUBSTVAR VAR)
PAT 3RDARG])
('MATCHELT
[LAMBDA (VAR PATELT) (* This function matches
VAR against PATELT when
PATELT is a pattern
element)
(COND
((NLISTP PATELT)
(SELECTQ PATELT
(($ -- &)
T)
('EQUAL VAR PATELT)))
(T (SELECTQ (CAR PATELT)
(==('EQ VAR (CDR PATELT)))
['('EQUAL VAR (KWOTE (CDR PATELT]
(=('EQUAL VAR (CDR PATELT)))
(SUBPAT ('MATCHSUBPAT VAR (CDR PATELT)))
[$PACKED$ (OR (NOT CHECKINGLENGTH)
('EQLENGTH VAR (CDR PATELT]
(HELP "INVALID PATTERN"])
('MATCHSUBPAT
[LAMBDA (VAR PATELT)
(PROG ((CHECKINGLENGTH PATCHECKLENGTH)
INASOME)
('MATCHWM VAR PATELT (QUOTE (TRUE])
)
(* Funargs for 'MATCHWM)
(DEFINEQ
(MAKE'SETQ
[LAMBDA (X ARGS) (* CAR ARGS is old PAT,
CDR ARGS is old FN)
('AND ['SETQ (CAR (CAR ARGS))
X
(CANMATCHNIL (CDR (CAR ARGS]
(BLKAPPLY* (CAR (CDR ARGS))
X
(CDDR ARGS])
(MAKEPOSTPONEDSETQ
[LAMBDA (X ARGS) (* CAR ARGS is old PAT,
CDR ARGS is old FN)
('AND [POSTPONEDSETQ (CAR (CAR ARGS))
X
(CANMATCHNIL (CDR (CAR ARGS]
(BLKAPPLY* (CAR (CDR ARGS))
X
(CDDR ARGS])
(MAKE'REPLACE
[LAMBDA (X ARGS) (* CAR ARGS is old PAT,
CDR ARGS is old FN)
('AND ('REPLACE X (CAR (CAR ARGS)))
(BLKAPPLY* (CAR (CDR ARGS))
X
(CDDR ARGS])
(MAKEPOSTPONEDREPLACE
[LAMBDA (X ARGS) (* CAR ARGS is old PAT,
CDR ARGS is old FN)
('AND (POSTPONEDREPLACE X (CAR (CAR ARGS)))
(BLKAPPLY* (CAR (CDR ARGS))
X
(CDDR ARGS])
(MAKE'APPLY*
[LAMBDA (X ARGS) (* CAR ARGS is old PAT,
CDR ARGS is old FN)
('AND ('APPLY* (CAR (CAR ARGS))
X)
(BLKAPPLY* (CAR (CDR ARGS))
X
(CDDR ARGS])
(MAKE'RETURN
[LAMBDA (X ARGS) (* ARGS is old FN)
(DOWATCH X)
('AND ('RETURN X)
(BLKAPPLY* (CAR ARGS)
X
(CDR ARGS])
(MAKE*GLITCH
[LAMBDA (X ARGS) (* CAR ARGS is old PAT,
CDR ARGS is old
(CDR ARGS))
(FRPLACA (CAR (CAR ARGS))
X)
(DOWATCH X)
(BLKAPPLY* (CAR (CDR ARGS))
X
(CDDR ARGS])
)
(* PREDICATES ON PATTERNS)
(DEFINEQ
(SKIP$I
[LAMBDA (PAT)
(* Returns to the first TAIL of PAT which doesn't
begin with a $i or a $$foo -
Sets the variable "LEN" to the total length of
things skipped over)
(SOME PAT (FUNCTION (LAMBDA (ELT)
(COND
((EQ ELT (QUOTE &))
(SETQ SKIPEDLEN ('PLUS 1 SKIPEDLEN))
NIL)
((EQ (CAR ELT)
(QUOTE $PACKED$))
(SETQ SKIPEDLEN ('PLUS SKIPEDLEN (CDR ELT)))
NIL)
(T])
(SKIP$ANY
[LAMBDA (PAT)
(* Scans PAT until a pattern element which matches
an arbitrary length segment is hit)
(* The free variables SETS and MATCH are set to T if
a set or MATCH (respectively) are found in any of
the pattern elements passed over)
(SOME PAT (FUNCTION (LAMBDA (ELT)
(PROG (TEM)
(COND
((SETQ TEM (PATLEN ELT))
[COND
((ZEROP TEM)
(SETQ ZLENFLG T))
(T (SETQ SKIPEDLEN ('PLUS SKIPEDLEN TEM]
NIL)
(T T])
(PATLEN
[LAMBDA (PATELT !ED)
(PROG NIL
LP (RETURN
(COND
[(NLISTP PATELT)
(SELECTQ PATELT
(($ --)
NIL)
(& (AND (NOT !ED)
1))
(COND
(!ED 0)
(T 1]
(T
(SELECTQ
(CAR PATELT)
(* (SETQ PATELT (CDR PATELT))
(GO LP))
(SUBPAT (COND
[!ED (for PE1 in (CDR PATELT) bind PLEN←0
finally (RETURN PLEN)
do (SETQ PLEN
('PLUS PLEN
(OR (PATLEN PE1)
(RETURN NIL]
(T 1)))
($PACKED$ (CDR PATELT))
((← -> <- → @ *GLITCH)
(SETQ PATELT (CDDR PATELT))
(GO LP))
(! (SETQ PATELT (CDR PATELT))
(SETQ !ED T)
(GO LP))
('(COND
(!ED (LENGTH (CDR PATELT)))
(T 1)))
((= ==)
(AND (NOT !ED)
1))
(HELP "INVALID PATTERN" PATELT])
($?
[LAMBDA (PATELT)
(OR (EQ PATELT (QUOTE --))
(EQ PATELT (QUOTE $])
(ELT?
[LAMBDA (PATELT)
(COND
[(NLISTP PATELT)
(OR (NUMBERP PATELT)
(STRINGP PATELT)
(FMEMB PATELT (QUOTE (& NIL T]
(T (SELECTQ (CAR PATELT)
((= == ' SUBPAT)
T)
((← -> <- → @ *GLITCH)
(ELT? (CDDR PATELT)))
( (*)
(ELT? (CDR PATELT)))
NIL])
(ARB?
[LAMBDA (PATELT)
(COND
((NLISTP PATELT)
($? PATELT))
(T (SELECTQ (CAR PATELT)
(! NIL)
(* (ARB? (CDR PATELT)))
((<- → ← -> *GLITCH)
(ARB? (CDDR PATELT)))
NIL])
(NULLPAT?
[LAMBDA (PAT)
(AND PAT (EVERY PAT (FUNCTION $?])
(CANMATCHNIL
[LAMBDA (PATELT)
(* Returns T if PATELT matches NIL, NIL if it
doesn't, and something ELSE
(maybe) if it might (e.g., =FOO))
(COND
((NLISTP PATELT)
(AND (FMEMB PATELT (QUOTE (& NIL $ --)))
T))
((NLISTP (CAR PATELT))
(SELECTQ (CAR PATELT)
[@ (AND (CANMATCHNIL (CDDR PATELT))
(NOT (FMEMB (CADR PATELT)
PATNONNILFUNCTIONS))
(QUOTE (MAYBE, MAYBE NOT]
(* (CANMATCHNIL (CDR PATELT)))
(SUBPAT (CANMATCHNILLIST (CDR PATELT)))
($PACKED$ (OR (NOT (NUMBERP (CDR PATELT)))
(ILESSP (CDR PATELT)
2)))
((← -> → <- *GLITCH)
(CANMATCHNIL (CDDR PATELT)))
(! (CANMATCHNIL (CDR PATELT)))
('(NULL (CDR PATELT)))
((= ==)
(AND PATVARSMIGHTBENIL (QUOTE MAYBE)))
(HELP "INVALID PATTERN" PATELT)))
(T (HELP "INVALID PATTERN ELEMENT"])
(CANMATCHNILLIST
[LAMBDA (PATLIST)
(EVERY PATLIST (FUNCTION (LAMBDA (PE)
(AND (NOT (ELT? PE))
(CANMATCHNIL PE])
(REPLACEIN
[LAMBDA (PATELT)
(AND (LISTP PATELT)
(SELECTQ (CAR PATELT)
((-> → *GLITCH)
(* the *GLITCH might or might not be a replace, but
can't take any chances)
T)
((@ ← <-)
(REPLACEIN (CDDR PATELT)))
(*
(* LEAVE ROOM FOR POSS THAT X:
(-- 'A --) ←FOO CONSTRUCTS MIGHT ARISE)
(REPLACEIN (CDR PATELT)))
(! (REPLACEIN (CDR PATELT)))
(SUBPAT (SOME (CDR PATELT)
(FUNCTION REPLACEIN)))
(($PACKED$ ≠ ≠≠ = == ') (* Not needed -
really LMDEBUG)
NIL)
(HELP "Invalid pattern?" PATELT])
(REPLACED
[LAMBDA (PAT)
(for X in PAT do (COND
((ELT? X)
(RETURN))
((REPLACEIN X)
(RETURN T])
)
(* LISP FUNCTION MANIPULATION)
(DEFINEQ
(EASYTORECOMPUTE
[LAMBDA (EXPRESSION)
(* If the EXPRESSION is some cadddaars of a
variable, return that variable
(something needs to check for VARS bound IN somes
and internal forms for WHEN it can't use it for the
*'s value))
(OR (AND (NLISTP EXPRESSION)
EXPRESSION)
(AND [OR (GETP (CAR EXPRESSION)
(QUOTE CROPS))
(FMEMB (CAR EXPRESSION)
(QUOTE (CAR CDR]
(EASYTORECOMPUTE (CADR EXPRESSION])
(FULLEXPANSION
[LAMBDA (X)
(PROG (TEM)
(COND
([OR (EQ (CAR X)
(QUOTE CAR))
(EQ (CAR X)
(QUOTE CDR))
(NULL (SETQ TEM (FASSOC (CAR X)
CRLIST]
X)
(T (LIST (CADDDR TEM)
(LIST (CAR (CDDDDR TEM))
(CADR X])
(GENSYML
[LAMBDA NIL
(OR (CAR (SETQ GENSYMVARLIST (CDR GENSYMVARLIST)))
(GENSYM])
(MAKESUBST0
[LAMBDA (OLD NEW)
(SETQ SUBLIST (CONS (LIST OLD NEW)
SUBLIST])
(MAKESUBSTLIST
[LAMBDA (SUBPRS EXPR)
(* This function substitues , for each element of
SUBPR (OLD . NEW) -
if OLD is found only once in EXPRESSION, then it is
directly substituted -
otherwise, a temp var is made up, bound,
(SETQ tem NEW) is substituted for the first
occurance, and the temp var for the rest)
(PROG NIL
LP (COND
[(NLISTP EXPR)
(COND
((NULL SUBPRS)
(RETURN EXPR))
(T [COND
((EQ (CAAR SUBPRS)
EXPR)
(SETQ EXPR (CADAR SUBPRS]
(SETQ SUBPRS (CDR SUBPRS))
(GO LP]
(SUBPRS (RETURN (OR (MAKESUBSTLIST1 EXPR)
EXPR)))
(T (RETURN EXPR])
(MAKESUBSTLIST1
[LAMBDA (EXPRESSION)
(PROG (TEM1 TEM2)
(COND
((NLISTP EXPRESSION)
NIL)
((SETQ TEM1 (FASSOC (CAR EXPRESSION)
SUBPRS))
(SETQ EXPRESSION (CONS (CAR EXPRESSION)
(CDR EXPRESSION)))
(COND
((LISTP (CDDR TEM1))
(SETQ TEM2 (BOUNDVAR))
(FRPLACA (CDDR TEM1)
('SETQ TEM2 (CADDR TEM1)))
(FRPLACA (CDR TEM1)
TEM2)
(FRPLACD (CDR TEM1)
T))
((NULL (CDDR TEM1)) (* Haven't seen it
before)
(FRPLACD (CDR TEM1)
EXPRESSION)))
(FRPLACA EXPRESSION (OR (MAKESUBSTLIST1 (CADR TEM1))
(CADR TEM1)))
(FRPLACD EXPRESSION (OR (MAKESUBSTLIST1 (CDR EXPRESSION))
(CDR EXPRESSION)))
EXPRESSION)
(T (PROG (A D)
(SETQ A (MAKESUBSTLIST1 (CAR EXPRESSION)))
(SETQ D (MAKESUBSTLIST1 (CDR EXPRESSION)))
(AND (OR A D)
(CONS (OR A (CAR EXPRESSION))
(OR D (CDR EXPRESSION])
(FORMEXPAND
[LAMBDA (LIST AT)
(* Searches for (AT --) AT the top level of list and
does a (1) up (bo 1) on them)
[for X on LIST do (AND (EQ (CAAR X)
AT)
(FRPLACD X (NCONC (CDDAR X)
(CDR X)))
(FRPLACA X (CADAR X]
LIST])
(POSTPONEDREPLACE
[LAMBDA (VAR VALUE)
(POSTPONE ('REPLACE VAR VALUE])
(POSTPONEDSETQ
[LAMBDA (VARTOSET VALUE CANBENILFLG)
(POSTPONE ('SETQ VARTOSET VALUE)
CANBENILFLG])
(POSTPONE
[LAMBDA (EFFECT FLG)
(SETQ LASTEFFECTCANBENIL FLG)
(SETQ POSTPONEDEFFECTS (NCONC1 POSTPONEDEFFECTS EFFECT))
(DOWATCH EFFECT)
T])
(SUBSTVAR
[LAMBDA (EXPR)
(PROG (TEM)
(MAKESUBST0 (SETQ TEM (GENSYML))
EXPR)
(RETURN TEM])
(BOUNDVAR
[LAMBDA NIL
(BINDVAR (GENSYML])
(BINDVAR
[LAMBDA (VAR)
(SETQ BINDINGS (CONS VAR BINDINGS))
VAR])
(SELFQUOTEABLE
[LAMBDA (EXPRESSION)
(OR (NUMBERP EXPRESSION)
(STRINGP EXPRESSION)
(NULL EXPRESSION)
(EQ EXPRESSION T])
(FINDIN0
[LAMBDA (VAR EXPR)
(OR (FINDIN1 VAR EXPR)
(SOME SUBLIST (FUNCTION (LAMBDA (X)
(AND (FINDIN1 (CAR X)
EXPR)
(FINDIN1 VAR (CDR X])
(FINDIN1
[LAMBDA (AT LST) (* CHEAP EDITFINDP)
(OR (EQ AT LST)
(AND (LISTP LST)
(OR (FINDIN1 AT (CAR LST))
(FINDIN1 AT (CDR LST])
(DOWATCH
[LAMBDA (EXPR)
(AND WATCHPOSTPONELST (MAP WATCHPOSTPONELST
(FUNCTION (LAMBDA (X)
(AND (NEQ (CAR X)
(QUOTE FOUND))
(FINDIN0 (CAR X)
EXPR)
(FRPLACA X (QUOTE FOUND])
(UNCROP
[LAMBDA (EXPR)
(COND
((NLISTP EXPR)
EXPR)
((GETP (CAR EXPR)
(QUOTE CROPS))
(UNCROP (CADR EXPR)))
(T (SELECTQ (CAR EXPR)
((CAR CDR NTH NLEFT LAST FLAST FNTH SOME)
(UNCROP (CADR EXPR)))
((MEMB FMEMB MEMBER)
(UNCROP (CADDR EXPR)))
EXPR])
)
(* LISP FUNCTION CONSTRUCTION)
(DEFINEQ
('NLEFT
[LAMBDA (EXPRESSION N TAIL NOTFASTFLG)
(COND
(TAIL (LIST (QUOTE NLEFT)
EXPRESSION N TAIL))
((ZEROP N) (* NO LOOKUP DONE SINCE
FLAST DOESN'T MAKE SENSE
HERE)
(LIST (QUOTE CDR)
(LIST (QUOTE LAST)
EXPRESSION)))
[(EQ N 1)
(COND
(NOTFASTFLG (LIST (QUOTE LAST)
EXPRESSION))
(T ('LAST EXPRESSION]
(T (LIST (QUOTE NLEFT)
EXPRESSION N])
('NOT
[LAMBDA (X)
('NOT1 X (QUOTE NOT])
('NULL
[LAMBDA (X)
('NOT1 X (QUOTE NULL])
('NOT1
[LAMBDA (X FNNAME)
(COND
((NLISTP X)
(SELECTQ X
(NIL T)
(T NIL)
(LIST FNNAME X)))
(T (SELECTQ (CAR X)
((NOT NULL)
(CADR X))
(EQ (FRPLACA X (QUOTE NEQ)))
(NEQ (FRPLACA X (QUOTE EQ)))
[(OR AND)
[for Y on (CDR X)
do (FRPLACA Y ('NOT (CAR Y]
(FRPLACA X (COND
((EQ (CAR X)
(QUOTE AND))
(QUOTE OR))
(T (QUOTE OR]
(LISTP (RPLACA X (QUOTE NLISTP)))
(NLISTP (FRPLACA X (QUOTE LISTP)))
(LIST FNNAME X])
('NOTLESSPLENGTH
[LAMBDA (X N)
(COND
((ZEROP N)
T)
(T ('NTH X N])
('NTH
[LAMBDA (VAR LEN)
(COND
((OR (NOT (NUMBERP LEN))
(IGREATERP LEN MAXCDDDDRS))
(LOOKLIST (QUOTE NTH)
VAR LEN))
(T (PROG NIL
LP (COND
((EQ LEN 1)
VAR)
((EQ LEN 2)
(LIST (QUOTE CDR)
VAR))
((EQ LEN 3)
(LIST (QUOTE CDDR)
VAR))
((EQ LEN 4)
(LIST (QUOTE CDDDR)
VAR))
((EQ LEN 5)
(LIST (QUOTE CDDDDR)
VAR))
(T (WHILE (IGREATERP LEN 5)
DO (SETQ VAR (LIST (QUOTE CDDDDR)
VAR))
(SETQ LEN (IDIFFERENCE LEN 4)))
(GO LP])
('OR
[LAMBDA (LISTOFEXPRESSIONS)
(COND
[(CDR LISTOFEXPRESSIONS)
(CONS (QUOTE OR)
(FORMEXPAND LISTOFEXPRESSIONS (QUOTE OR]
(T (CAR LISTOFEXPRESSIONS])
('PLUS
[LAMBDA (EXPR1 EXPR2)
(COND
((AND (NUMBERP EXPR1)
(NUMBERP EXPR2))
(IPLUS EXPR1 EXPR2))
(T (PROG ((SUM 0)
(LST (FORMEXPAND (LIST EXPR1 EXPR2)
(QUOTE IPLUS)))
VAL)
[FOR X in LST do (COND
((NUMBERP X)
(SETQ SUM (IPLUS X SUM)))
(T (SETQ VAL (NCONC1 VAL X]
(COND
((NULL VAL) SUM)
((IGREATERP SUM 0)
(CONS (QUOTE IPLUS)
(CONS SUM VAL)))
((NULL (CDR VAL))
(CAR VAL))
(T (CONS (QUOTE IPLUS)
VAL])
('REPLACE
[LAMBDA (VAR EXPRESSION)
(SETQ VAR (FULLEXPANSION VAR))
(COND
((EQ (CAR VAR)
(QUOTE CAR))
(LOOKLIST (QUOTE RPLACA)
(CADR VAR)
EXPRESSION))
((EQ (CAR VAR)
(QUOTE CDR))
(LOOKLIST (QUOTE RPLACD)
(CADR VAR)
EXPRESSION))
[(EQ (CAR VAR)
(QUOTE LDIFF))
('REPLACE (CADR VAR)
(LIST (QUOTE NCONC)
EXPRESSION
(CADDR VAR]
(T (LIST (QUOTE RPLNODE2)
VAR EXPRESSION])
('SETQ
[LAMBDA (VAR EXPRESSION PROGNFLG)
(SETQ EXPRESSION (LIST (QUOTE SETQ)
VAR EXPRESSION))
(COND
(PROGNFLG (LIST (QUOTE PROGN)
EXPRESSION T))
(T EXPRESSION])
('AND
[LAMBDA N
(PROG ((NARGS N)
EXPR1 EXPR2)
(SETQ EXPR2 (ARG N NARGS))
LP (SETQ NARGS (SUB1 NARGS))
(COND
((ZEROP NARGS)
(RETURN EXPR2)))
(SETQ EXPR1 (ARG N NARGS))
(SETQ EXPR2 ('AND2 EXPR1 EXPR2))
(GO LP])
('AND2
[LAMBDA (EXPR1 EXPR2)
(PROG (TEM)
(COND
((EQ EXPR1 T)
EXPR2)
((EQ EXPR2 T)
EXPR1)
((EQUAL EXPR1 (UNCROP EXPR2))
EXPR2)
((EQ (CAR EXPR1)
(QUOTE PROGN))
(SETQ TEM (FLAST EXPR1))
(FRPLACA TEM ('AND (CAR TEM)
EXPR2))
EXPR1)
((AND (EQ (CAR EXPR2)
(QUOTE COND))
(NOT (CDDR EXPR2)))
(FRPLACA (CADR EXPR2)
('AND EXPR1 (CAADR EXPR2)))
EXPR2)
((AND (EQ (CAR EXPR1)
(QUOTE COND))
(NULL (CDDR EXPR1)))
(FRPLACA (SETQ TEM (FLAST (CADR EXPR1)))
('AND (CAR TEM)
EXPR2))
EXPR1)
((AND (EQ (CAR EXPR2)
(QUOTE OR))
(EQ (CADDR EXPR2)
T))
(LIST (QUOTE COND)
(LIST EXPR1 (CADR EXPR2)
T)))
[(EQ (CAR EXPR2)
(QUOTE PROGN))
(LIST (QUOTE COND)
(CONS EXPR1 (CDR EXPR2]
[(EQ (CAR EXPR2)
(QUOTE AND))
(COND
((EQ (CAR EXPR1)
(QUOTE AND))
(NCONC EXPR1 (CDR EXPR2)))
(T (FRPLACD EXPR2 (CONS EXPR1 (CDR EXPR2]
((EQ (CAR EXPR1)
(QUOTE AND))
(NCONC1 EXPR1 EXPR2))
[(AND [OR (AND (EQ (CAR EXPR1)
(QUOTE SETQ))
(SETQ TEM EXPR1))
(AND (EQ (CAR EXPR1)
(QUOTE OR))
(EQ (CAADR EXPR1)
(QUOTE SETQ))
(EQ (CADDR EXPR1)
T)
(SETQ TEM (CADR EXPR1]
(COND
((EQ EXPR2 (CADR TEM))
TEM)
((AND (EQ (CAR EXPR2)
(QUOTE AND))
(EQ (CADR TEM)
(CADR EXPR2)))
(FRPLACA (CDR EXPR2)
TEM)
EXPR2]
[(AND (EQ (CAR EXPR1)
(QUOTE PROG))
(PROG (TEM)
(AND (EQ (CAR (SETQ TEM (NLEFT (CDR EXPR1)
2)))
(QUOTE $$SOMELP))
(EQ (CAADR TEM)
(QUOTE COND))
(NULL (CDR (CDDADR TEM)))
[EQUAL (LAST (CDAR (CDDADR TEM)))
(QUOTE ((GO $$SOMELP]
(SETQ TEM (FLAST (CADADR TEM)))
(FRPLACA TEM ('AND (CAR TEM)
EXPR2))
(RETURN EXPR1]
(T (LIST (QUOTE AND)
EXPR1 EXPR2])
('CAR
[LAMBDA (X)
(PROG (TEM)
(COND
([NULL (SETQ TEM (CADR (FASSOC (CAR X)
CRLIST]
(LIST (QUOTE CAR)
X))
(T (LIST TEM (CADR X])
('CDR
[LAMBDA (X)
(PROG (TEM)
(COND
([NULL (SETQ TEM (CADDR (FASSOC (CAR X)
CRLIST]
(LIST (QUOTE CDR)
X))
(T (LIST TEM (CADR X])
('EQ
[LAMBDA (VAR EXPRESSION)
(COND
((NULL EXPRESSION)
('NULL VAR))
((ZEROP EXPRESSION)
(LIST (QUOTE ZEROP)
VAR))
(T (LIST (QUOTE EQ)
VAR EXPRESSION])
('EQLENGTH
[LAMBDA (VAR LEN)
(* THIS SHOULD REALLY TAKE
(EQLENGTH (CDDDR X) 10) AND TRANSLATE IT TO
(EQLENGTH X 13))
(COND
((EQ (CAR VAR)
(QUOTE CDR))
('EQLENGTH (CADR VAR)
('PLUS LEN 1)))
((EQ (CAR VAR)
(QUOTE CDDR))
('EQLENGTH (CADR VAR)
('PLUS LEN 2)))
((EQ (CAR VAR)
(QUOTE CDDDDR))
('EQLENGTH (CADR VAR)
('PLUS LEN 3)))
((EQ (CAR VAR)
(QUOTE CDDDR))
('EQLENGTH (CADR VAR)
('PLUS LEN 3)))
((ZEROP LEN)
('NULL VAR))
(T (LIST (QUOTE EQLENGTH)
VAR LEN])
('EQUAL
[LAMBDA (VAR EXPRESSION)
[COND
((AND (EQ (CAR EXPRESSION)
(QUOTE QUOTE))
(SELFQUOTEABLE (CADR EXPRESSION)))
(SETQ EXPRESSION (CADR EXPRESSION]
(COND
((NULL EXPRESSION)
('NULL VAR))
((EQ EXPRESSION T)
('EQ VAR EXPRESSION))
(T (LIST (COND
([OR (SMALLP EXPRESSION)
(AND (EQ (CAR EXPRESSION)
(QUOTE QUOTE))
(LITATOM (CADR EXPRESSION]
(QUOTE EQ))
((NUMBERP EXPRESSION)
(QUOTE EQP))
((STRINGP EXPRESSION)
(QUOTE STREQUAL))
(T (QUOTE EQUAL)))
VAR EXPRESSION])
('LAST
[LAMBDA (X)
(LIST (LOOK (QUOTE LAST)
X)
X])
('RETURN
[LAMBDA (VALUE)
(COND
(STARREPLACED ('REPLACE VALUE STARREPLACED))
(T (SETQ MUSTRETURN VALUE)
T])
('F/L
[LAMBDA (ARGS EXPR)
(DSUBST (CAR ARGS)
('CAR (CADR ARGS))
EXPR)
(LIST (QUOTE FUNCTION)
(COND
([AND (EQ (CADR EXPR)
(CAR ARGS))
(OR (AND (EQLENGTH EXPR 2)
(EQ (NARGS (CAR EXPR))
1))
(AND (EQ (NARGS (CAR EXPR))
1)
(EQLENGTH EXPR 3)
(EQ (CADDR EXPR)
(CADR ARGS]
(CAR EXPR))
(T (LIST (QUOTE LAMBDA)
ARGS EXPR])
('APPLY*
[LAMBDA (FNNAME VAR)
(COND
((OR (NLISTP FNNAME)
(EQ (CAR FNNAME)
(QUOTE LAMBDA)))
(LIST FNNAME VAR))
(T (SUBST VAR (QUOTE @)
FNNAME])
('HEADPLOOP
[LAMBDA (VAR HEADLIST TAILVAR CANNILFLG AFTEREXP)
('PROG
NIL
(LIST ('SETQ TAILVAR VAR)
('SETQ (SETQ VAR (BOUNDVAR))
HEADLIST)
(QUOTE $$LP)
(LIST (QUOTE COND)
[LIST (LIST (QUOTE NLISTP)
VAR)
(COND
[(EQ AFTEREXP T)
('OR (LIST ('NULL VAR)
('EQ VAR TAILVAR]
((NOT CANNILFLG)
('AND ('NULL VAR)
AFTEREXP))
(T ('AND ('OR (LIST ('NULL VAR)
('EQ VAR TAILVAR)))
AFTEREXP]
(LIST ('AND ('LISTP TAILVAR)
('EQUAL ('CAR TAILVAR)
('CAR VAR)))
('SETQ TAILVAR ('CDR TAILVAR))
('SETQ VAR ('CDR VAR))
(QUOTE (GO $$LP])
('LDIFF
[LAMBDA (X Y)
(LIST (QUOTE LDIFF)
X Y])
('PROG
[LAMBDA (VARS STATEMENTS)
(COND
((AND (NULL (CDR STATEMENTS))
(EQ (CAAR STATEMENTS)
(QUOTE PROG)))
(RPLACA (CDAR STATEMENTS)
(APPEND (CADAR STATEMENTS)
VARS))
(CAR STATEMENTS))
(T (CONS (QUOTE PROG)
(CONS VARS STATEMENTS])
('FOR
[LAMBDA ({OLD⎇ I.V. {ON⎇VAR {UNTIL⎇EXPR {FINALLY⎇EXPR NOSOMEFLG)
(PROG (TEM1)
[COND
((EQ {UNTIL⎇EXPR T)
(HELP
"error in pattern match, a SOME with null terminator"
(LIST {OLD⎇ I.V. {ON⎇VAR {FINALLY⎇EXPR]
(COND
(NOSOMEFLG (GO DOPROG)))
(SELECTQ (CAR {UNTIL⎇EXPR)
[EQ (AND (EQUAL (CADR {UNTIL⎇EXPR)
('CAR I.V.))
(SETQ TEM1 (LOOKLIST (QUOTE MEMB)
(CADDR {UNTIL⎇EXPR)
{ON⎇VAR]
[EQUAL (AND (EQUAL (CADR {UNTIL⎇EXPR)
('CAR I.V.))
(SETQ TEM1 (LIST (QUOTE MEMBER)
(CADDR {UNTIL⎇EXPR)
{ON⎇VAR]
NIL)
(COND
[(NOT TEM1)
(COND
({OLD⎇ (GO DOPROG]
[(OR {OLD⎇ (NEQ {FINALLY⎇EXPR T))
(MAKESUBST0 I.V. TEM1)
(* OLD on means that I.V. is going to be used later
on. Thus, we set up to substitute TEM1 for I.V.
later, and return I.V. now)
(RETURN (COND
((NEQ {FINALLY⎇EXPR T)
{FINALLY⎇EXPR)
(T I.V.]
(T (GO RET)))
(SETQ TEM1 (LIST (QUOTE SOME)
{ON⎇VAR
('F/L (LIST (GENSYML)
I.V.)
{UNTIL⎇EXPR)))
RET [RETURN (COND
((EQ {FINALLY⎇EXPR T)
TEM1)
(T (* Can use DSUBST
directly, since I.V.
occurs nowhere else)
(DSUBST TEM1 I.V. {FINALLY⎇EXPR]
DOPROG
(RETURN
('PROG (AND (NOT {OLD⎇)
(LIST (LIST I.V. {ON⎇VAR)))
(APPEND (AND {OLD⎇ (LIST ('SETQ (BINDVAR I.V.)
{ON⎇VAR)))
(LIST (QUOTE $$SOMELP)
(LIST (QUOTE COND)
(LIST {UNTIL⎇EXPR {FINALLY⎇EXPR)
(LIST ('LISTP I.V.)
('SETQ I.V. ('CDR I.V.))
(LIST (QUOTE GO)
(QUOTE $$SOMELP])
('PROGN
[LAMBDA (LISTOFEXPRESSION)
(COND
((CDR LISTOFEXPRESSION)
(CONS (QUOTE PROGN)
LISTOFEXPRESSION))
(T (CAR LISTOFEXPRESSION])
('LISTP
[LAMBDA (X)
(LIST (QUOTE LISTP)
X])
)
(* PATTERN PARSER)
(DEFINEQ
(PATPARSE
[LAMBDA (PAT)
[SETQ PAT (PATPARSE1 (COND
((NLISTP PAT)
(LIST (QUOTE !)
PAT))
(T (COPY PAT]
[AND (LITATOM (CAR PAT))
[NOT (FMEMB (CAR PAT)
(QUOTE (& -- NIL T $]
(PATERR (CONCAT "A pattern cannot begin with a " (CAR PAT]
PAT])
(PATPARSE1
[LAMBDA (PAT BACKPAT)
(* Smashes PAT with it's parsing;
BACKPAT is the previous pattern back -
If it was VAR or !, leave it alone -
If it was a pattern, then don't PATPARSE the next
thing, since it's an expression)
(PROG (LASTTYPE TEM)
(COND
((NULL PAT)
(RETURN)))
RETRY
[COND
[(LITATOM (CAR PAT))
(SELECTQ (CAR PAT)
((= == $PACKED$)
(PATPARSEXPR (CDR PAT))
(BI12 PAT))
('(BI12 PAT))
($$ (FRPLACA PAT (QUOTE --)))
($1 (FRPLACA PAT (QUOTE &)))
[* (FRPLACA PAT (CONS (QUOTE *)
(QUOTE &]
((& -- $ ! %. T NIL)
T)
[←(COND
((NEQ BACKPAT (QUOTE VAR))
(PATPARSEXPR (CDR PAT))
(PATPARSE1 (CDDR PAT))
(RETURN PAT]
(@ (PATPARSEXPR (CDR PAT))
(PATPARSE1 (CDDR PAT))
(RETURN PAT))
((# } *ANY* *EVERY* ≠ ≠≠)
(PATERR (CONCAT (CAR PAT)
" not implemented")))
(COND
((PATPARSEAT PAT (STRPOSL PATCHARRAY
(CAR PAT)
1)
PATCHARS)
(* Otherwise, try to
PATPARSEAT (CAR PAT))
(GO RETRY))
(T (* Must have a variable
here!)
(SETQQ LASTTYPE VAR]
[(NLISTP (CAR PAT))
(OR (STRINGP (CAR PAT))
(NUMBERP (CAR PAT))
(PATERR (CONCAT "Pattern item not atom or list: "
(CAR PAT]
(T (* Otherwise, there is a
subpattern)
(PATPARSE1 (CAR PAT))
(FRPLACA PAT (MAKESUBPAT (CAR PAT]
[AND (CDR PAT)
(NLISTP (CDR PAT))
(FRPLACD PAT (LIST (QUOTE %.)
(CDR PAT]
(PATPARSE1 (CDR PAT)
(OR LASTTYPE (CAR PAT)))
REPARSE
(COND
[(EQ (CADR PAT)
(QUOTE ←))
(* CASES FOR "←" -
(1) pat←expr ---> (-> expr . pat) -
(2) var←pat ----> (← var . pat) -
(3) !var←pat ---> (← var ! SUBPAT . restofpattern) -
(4) !←expr -----> (-> expr ! SUBPAT . restofpattern))
(COND
((FMEMB (CAR PAT)
(QUOTE (! %.))) (* !←expr)
[FRPLACA
PAT
(CONS (COND
((OR (NULL POSTPONEFLG)
(EQ POSTPONEFLG (QUOTE ->)))
(QUOTE →))
(T (QUOTE ->)))
(CONS (CADDR PAT)
(COND
[(OR (CDDDDR PAT)
(ELT? (CADDDR PAT)))
(MAKE!PAT (MAKESUBPAT (CDDDR PAT]
(T (CADDDR PAT]
(FRPLACD PAT NIL))
[(EQ LASTTYPE (QUOTE VAR)) (* var←pat or !var←pat
to ((← var . pat) ...))
(COND
((CDDR PAT)
[FRPLACA PAT
(CONS (COND
((AND POSTPONEFLG
(NEQ POSTPONEFLG
(QUOTE ->)))
(QUOTE <-))
(T (QUOTE ←)))
(CONS (CAR PAT)
(CADDR PAT]
(FRPLACD PAT (CDDDR PAT)))
(T (PATERR "nothing after a '←' in a pattern"]
(T (* pat←expr)
(SETQ TEM (CAR PAT))
(FRPLACA PAT (CDR PAT))
(FRPLACD PAT (CDDDR PAT))
(FRPLACD (CDAR PAT)
TEM)
(FRPLACA (CAR PAT)
(COND
(POSTPONEFLG (QUOTE ->))
(T (QUOTE →]
[(FMEMB (CAR PAT)
(QUOTE (! %.)))
(COND
([AND (EQ (CAR PAT)
(QUOTE !))
(FMEMB (CAADR PAT)
(QUOTE (<- ←]
(* Got (! (← var . pe) ...) from !VAR←PE change it
to (← var ! subpat pe . ...) unless ...
is NIL and pe is not ELT , in which case, just
((← VAR . pe)))
[FRPLACA
PAT
(COND
([AND (NULL (CDDR PAT))
(NOT (ELT? (CDDR (CADR PAT]
(CADR PAT))
(T
(CONS
(CAADR PAT)
(CONS
(CADR (CADR PAT))
(MAKE!PAT
(MAKESUBPAT (CONS (CDDR (CADR PAT))
(CDDR PAT]
(FRPLACD PAT NIL))
(T (FRPLACA PAT (MAKE!PAT (CADR PAT)))
(FRPLACD PAT (CDDR PAT]
[(EQ LASTTYPE (QUOTE VAR)) (* var not followed by
←... it's a VARDEFAULT)
(FRPLACA PAT (MAKEDEFAULT (CAR PAT]
((EQ (CADR PAT)
(QUOTE @))
[FRPLACA PAT (CONS (QUOTE @)
(CONS (CADDR PAT)
(CAR PAT]
(FRPLACD PAT (CDDDR PAT)))
(T (RETURN PAT)))
(SETQ LASTTYPE NIL)
(GO REPARSE])
(PATPARSEAT
[LAMBDA (PAT POS CHRS)
(* Breaks apart (CAR PAT) if possible, replaces the
parsing into the beginning of PAT ;
otherwise return NIL if can't -
POS is the result from STRPOSL -
CHRS is a list of args to STRPOS, i.e. check
(STRPOS X:1 PAT:1 1 NIL X:2) for X in CHRS -
X:1 is the char list, X:2 is ANCHOR)
(PROG (TEM)
(AND (NULL POS)
(RETURN))
LP (COND
((NULL CHRS)
(RETURN))
((NOT (SETQ POS (STRPOS (CAAR CHRS)
(CAR PAT)
1 NIL (CADAR CHRS)
NIL)))
(SETQ CHRS (CDR CHRS))
(GO LP)))
(* Found one -
Use this rather than getting pos, since some of
PATCHARS are more than one char)
[SETQ TEM (IPLUS POS (CADDR (CAR CHRS]
(COND
[[NOT (IGREATERP TEM (NCHARS (CAR PAT]
(FRPLACD PAT (CONS (MKATOM (SUBSTRING (CAR PAT)
TEM))
(CDR PAT]
(T (SETQ TEM NIL)))
[SETQ TEM (COND
([AND TEM (EQ (CAAR CHRS)
(QUOTE $))
(NOT (FMEMB (NTHCHAR (CAR PAT)
TEM)
(QUOTE (← @]
(QUOTE $PACKED$))
(T (CAAR CHRS]
(COND
[(NEQ POS 1)
(FRPLACD PAT (CONS TEM (CDR PAT)))
(FRPLACA PAT (MKATOM (SUBSTRING (CAR PAT)
1
(SUB1 POS]
(T (FRPLACA PAT TEM)))
(RETURN T])
(PATPARSEXPR
[LAMBDA (PAT) (* Look for ←'s in
(CAR PAT))
(AND (LITATOM (CAR PAT))
(PATPARSEAT PAT (STRPOSL PATCHARRAY (CAR PAT)
1)
(QUOTE ((@ NIL 1)
(← NIL 1])
(BI12
[LAMBDA (PAT) (* This changes
(A B ...) to
((A . B) ...))
(COND
((OR (NLISTP PAT)
(NLISTP (CDR PAT)))
(HELP "error in pattern match, at BI12" PAT)))
(PROG ((TEM (CDR PAT)))
(FRPLACD PAT (CDDR PAT))
(FRPLACD TEM (CAR TEM))
(FRPLACA TEM (CAR PAT))
(FRPLACA PAT TEM])
(MAKEDEFAULT
[LAMBDA (PATELT LOCALVARDEFAULT)
(* Turns PATELT (which is a LITATOM) into the
"DEFAULT" pattern -
I.e. PATELT couldn't be parsed as a pattern -
It is assumed that the default for an atom is an
element pattern)
(OR (AND (LITATOM PATELT)
(NEQ PATELT T)
PATELT)
(HELP "error in pattern matcher at MAKEDEFAULT" PATELT))
(SELECTQ (OR LOCALVARDEFAULT VARDEFAULT)
[(← SETQ SET)
(CONS (COND
(POSTPONEFLG (QUOTE <-))
(T (QUOTE ←)))
(CONS PATELT (QUOTE $1]
((QUOTE ')
(CONS (QUOTE ')
PATELT))
((= EQUAL)
(VARCHECK PATELT)
(CONS (QUOTE =)
PATELT))
((== EQ)
(VARCHECK PATELT)
(CONS (QUOTE ==)
PATELT))
[(@ APPLY*)
(FNCHECK PATELT)
(CONS (QUOTE @)
(CONS PATELT (QUOTE &]
(COND
((SETQ LOCALVARDEFAULT (FNCHECK PATELT T T T))
(MAKEDEFAULT LOCALVARDEFAULT (QUOTE @)))
((SETQ LOCALVARDEFAULT (VARCHECK PATELT T T T))
(MAKEDEFAULT LOCALVARDEFAULT (QUOTE =)))
(T (PATERR (CONCAT "What is the meaing of " PATELT])
(MAKE!PAT
[LAMBDA (PATELT)
(OR (COND
((NLISTP PATELT)
(SELECTQ PATELT
(& (QUOTE --))
(($ --)
(QUOTE $))
NIL))
(T (SELECTQ (CAR PATELT)
(! (PATERR "Two !'s in a row"))
((← <- → -> @)
(FRPLACD (CDR PATELT)
(MAKE!PAT (CDDR PATELT)))
PATELT)
[* (FRPLACD PATELT (MAKE!PAT (CDR PATELT]
(SUBPAT (AND (NULL (CDDR PATELT))
(NOT (ELT? (CADR PATELT)))
(CADR PATELT)))
($PACKED$ PATELT)
NIL)))
(CONS (QUOTE !)
PATELT])
(MAKESUBPAT
[LAMBDA (PATLST)
(COND
((NULL PATLST)
NIL)
([OR (EQUAL PATLST (QUOTE (--)))
(EQUAL PATLST (QUOTE ($]
(QUOTE &))
(T (CONS (QUOTE SUBPAT)
PATLST])
)
(* FUNCTIONS, CALLS TO WHICH ARE GENERATED)
(DEFINEQ
(EQLENGTH
[LAMBDA (X N)
(COND
((ZEROP N)
(NLISTP X))
(T (AND (SETQ X (NTH X N))
(NLISTP (CDR X])
(RPLNODE2
[LAMBDA (X Y)
(RPLNODE X (CAR Y)
(CDR Y])
(/RPLNODE2
[LAMBDA (X Y)
(/RPLNODE X (CAR Y)
(CDR Y])
)
(* MISC)
(DEFINEQ
(PATERR
[LAMBDA (MSG)
(ERROR (CONCAT (OR MSG "bad pattern")
" in:")
TOPPAT])
(PATWARN
[LAMBDA (MSG)
(LISPXPRIN1 MSG T)
(LISPXPRIN1 " in " T)
(LISPXPRINT TOPPAT T])
(LOOKLIST
[LAMBDA (FN ARG ARG')
(LIST (LOOK FN ARG ARG')
ARG ARG'])
(LOOK
[LAMBDA (FN ARG ARG')
(CLISPLOOKUP FN ARG ARG'(GETP FN (QUOTE LISPFN])
(CLISPLOOKUP
[LAMBDA (FN VAR1 VAR2 LISPFN)
(* In most cases, it is not necessary to do a full
lookup. This is q uick an dirty check inside of the
block to avoid calling CLISPLOOKUP0 It will work
whenever there are no declarations.
Only difference between this and CLISPIFYLOOKUP is
that is that we already have performed
(GETP FN 'LISPFN))
(PROG (CLASS TEM)
(RETURN (COND
([OR (AND (SETQ CLASS (GETP FN (QUOTE CLISPCLASS)))
(EQ (CAR (SETQ TEM (CADDR EXPR)))
(QUOTE *))
(EQ (CADR TEM)
(QUOTE DECLARATIONS:))
(SETQ TEM (CDDDR TEM)))
(AND (EQ (CAR TEM)
(QUOTE CLISP:))
(SETQ TEM (CLISPDEC0 TEM FAULTFN]
(* must do full lookup.)
(CLISPLOOKUP0 FN VAR1 VAR2 TEM CLASS))
(T (OR LISPFN FN])
(VARCHECK
[LAMBDA (VAR NOMESSFLG SPELLFLG PROPFLG)
(* Checks if VAR is really a variable -
Used by MAKEDEFAULT to avoid bad parsings)
(OR (AND (LITATOM VAR)
(NEQ (EVALV VAR)
(QUOTE NOBIND))
VAR)
(COND
(NOMESSFLG NIL)
(T (ERROR VAR "NOT A VARIABLE" T])
(TRUE
[LAMBDA NIL T])
)
(RPAQQ VARDEFAULT NIL)
(RPAQQ MAXCDDDDRS 5)
(RPAQQ POSTPONEFLG T)
(RPAQQ PATCHECKLENGTH NIL)
(RPAQQ POSTPONEFLG T)
(RPAQQ PATCAREVALUE T)
(RPAQQ CRLIST ((CAR CAAR CDAR CAR NIL)
(CDR CADR CDDR CDR NIL)
(CDDDDR NIL NIL CDR CDDDR)
(CADDDR NIL NIL CAR CDDDR)
(CDDDR CADDDR CDDDDR CDR CDDR)
(CDADDR NIL NIL CDR CADDR)
(CAADDR NIL NIL CAR CADDR)
(CADDR CAADDR CDADDR CAR CDDR)
(CDDR CADDR CDDDR CDR CDR)
(CDDADR NIL NIL CDR CDADR)
(CADADR NIL NIL CAR CDADR)
(CDADR CADADR CDDADR CDR CADR)
(CDAADR NIL NIL CDR CAADR)
(CAAADR NIL NIL CAR CAADR)
(CAADR CAAADR CDAADR CAR CADR)
(CADR CAADR CDADR CAR CDR)
(CDDDAR NIL NIL CDR CDDAR)
(CADDAR NIL NIL CAR CDDAR)
(CDDAR CADDAR CDDDAR CDR CDAR)
(CDADAR NIL NIL CDR CADAR)
(CAADAR NIL NIL CAR CADAR)
(CADAR CAADAR CDADAR CAR CDAR)
(CDAR CADAR CDDAR CDR CAR)
(CDDAAR NIL NIL CDR CDAAR)
(CADAAR NIL NIL CAR CDAAR)
(CDAAR CADAAR CDDAAR CDR CAAR)
(CDAAAR NIL NIL CDR CAAAR)
(CAAAAR NIL NIL CAR CAAAR)
(CAAAR CAAAAR CDAAAR CAR CAAR)
(CAAR CAAAR CDAAR CAR CAR)))
(RPAQQ PATCHARS ((' T 1)
(← NIL 1)
(@ NIL 1)
(! T 1)
(== T 2)
(= T 1)))
(RPAQQ PATNONNILFUNCTIONS (GETD NUMBERP STRINGP ZEROP LISTP))
(RPAQQ PATVARSMIGHTBENIL T)
(DEFLIST(QUOTE(
[EVERY (X (CMAP X (QUOTE (CAR MACROX))
(QUOTE (EVERYLP (COND ((NLISTP MACROX)
(RETURN T))
((NOT MAPF)
(RETURN NIL)))
(SETQ MACROX MAPF2)
(GO EVERYLP]
))(QUOTE MACRO))
[ADDTOVAR PRETTYMACROS (* X (E (TERPRI)
(PRINT (QUOTE (* . X)))
(TERPRI]
[SETQ PATCHARRAY (MAKEBITTABLE (MAPCAR PATCHARS (QUOTE CAR]
(DECLARE
(BLOCK: MATCHBLOCK MAKEMATCH 'MATCHWM 'MATCHTOP 'MATCHEXP 'MATCHELT
'MATCHSUBPAT MAKE'SETQ MAKEPOSTPONEDSETQ MAKE'REPLACE
MAKEPOSTPONEDREPLACE MAKE'APPLY* MAKE'RETURN MAKE*GLITCH
SKIP$I SKIP$ANY PATLEN $? ELT? ARB? NULLPAT? CANMATCHNIL
CANMATCHNILLIST REPLACEIN REPLACED EASYTORECOMPUTE
FULLEXPANSION GENSYML MAKESUBST0 MAKESUBSTLIST MAKESUBSTLIST1
FORMEXPAND POSTPONEDREPLACE POSTPONEDSETQ POSTPONE SUBSTVAR
BOUNDVAR BINDVAR SELFQUOTEABLE FINDIN0 FINDIN1 DOWATCH UNCROP
'NLEFT 'NOT 'NULL 'NOT1 'NOTLESSPLENGTH 'NTH 'OR 'PLUS
'REPLACE 'SETQ 'AND 'AND2 'CAR 'CDR 'EQ 'EQLENGTH 'EQUAL
'LAST 'RETURN 'APPLY* 'HEADPLOOP 'LDIFF 'PROG 'FOR 'F/L
'PROGN 'LISTP PATPARSE PATPARSE1 PATPARSEAT PATPARSEXPR BI12
MAKEDEFAULT MAKE!PAT MAKESUBPAT PATERR PATWARN CLISPLOOKUP
VARCHECK TRUE (ENTRIES MAKEMATCH)
(GLOBALVARS PATCHARRAY PATCHARS POSTPONEFLG VARDEFAULT CRLIST
PATCHECKLENGTH MAXCDDDDRS PATNONNILFUNCTIONS
PATVARSMIGHTBENIL)
(LOCALFREEVARS WATCHPOSTPONELST SUBLIST TOPPAT INASOME
CHECKINGLENGTH WMLST LASTEFFECTCANBENIL
POSTPONEDEFFECTS MUSTRETURN BINDINGS
GENSYMVARLIST SKIPEDLEN ZLENFLG SUBPRS
STARREPLACED)
(SPECVARS STARREPLACED)
(BLKAPPLYFNS TRUE MAKE'RETURN MAKE*GLITCH MAKE'SETQ
MAKEPOSTPONEDSETQ MAKE'REPLACE
MAKEPOSTPONEDREPLACE MAKE'APPLY* 'MATCHWM
'MATCHSUBPAT))
(BLOCK: NIL EQLENGTH (LINKFNS . T))
)STOP